home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / eval.lisp < prev    next >
Encoding:
Text File  |  1992-01-30  |  13.1 KB  |  456 lines
  1. ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-INTERNAL; -*-
  2. ; File eval.lisp / Copyright (c) 1991 Jonathan Rees / See file COPYING
  3.  
  4. ;;;; Pseudoscheme runtime system
  5.  
  6. (lisp:in-package "SCHEME-INTERNAL")
  7.  
  8. (use-package "SCHEME-TRANSLATOR")
  9.  
  10. (export '(
  11.       ;; User environment
  12.       scheme-user-environment
  13.  
  14.       ;; Invoking the translator
  15.       scheme-eval
  16.       scheme-load
  17.       scheme-compile
  18.       scheme-compile-file
  19.       translate-file
  20.  
  21.       ;; REP loop
  22.       set-rep-environment!
  23.       scheme
  24.       quit
  25.  
  26.       ;; Utilities
  27.       scheme-error
  28.       pp
  29.       ))
  30.  
  31. (proclaim '(special scheme-user-environment))
  32.  
  33. ;; User environment
  34.  
  35. ;(defvar scheme-user-environment
  36. ;  (locally (declare (special scheme-translator::scheme-user-environment))
  37. ;    scheme-translator::scheme-user-environment))
  38.  
  39. (defvar *current-rep-environment* scheme-user-environment)
  40.  
  41. (defvar *target-environment* scheme-user-environment) ;?
  42.  
  43. ; EVAL itself
  44.  
  45. (defun scheme-eval (form env)
  46.   (eval (translate form env)))
  47.  
  48. ; COMPILE -- compile a single procedure
  49. ;  (compile symbol)  is like (set! symbol (compile lambda-expression))
  50.  
  51. (defun scheme-compile (name-or-source)
  52.   (let ((env *current-rep-environment*))
  53.     (cond ((symbolp name-or-source)
  54.        (let ((CL-sym (find-symbol-renaming-perhaps
  55.                (symbol-name name-or-source)
  56.                (program-env-package env))))
  57.          (compile CL-sym)
  58.          (set-value-from-function CL-sym)))
  59.       (t
  60.        (compile nil (translate-lambda name-or-source env))))))
  61.  
  62. ; "Roadblock" readtable.  Behaves exactly like a regular Common Lisp
  63. ; read table, except when the SCHEME package (or a package associated
  64. ; with the current Scheme environment) is current, in which case it reads
  65. ; a form using the Scheme readtable and package, then wraps (BEGIN
  66. ; ...) around it so that the translator will kick in and translate the
  67. ; form.
  68.  
  69. (defparameter roadblock-readtable (copy-readtable scheme-readtable))
  70.  
  71. #+Symbolics
  72. (pushnew roadblock-readtable si:*valid-readtables*)
  73.  
  74. (defun roadblock-read-macro (stream ch)
  75.   (unread-char ch stream)
  76.   (if (or (eq *package* scheme-package)
  77.       (eq *package* (program-env-package *target-environment*))
  78.       (eq *package* (program-env-package *current-rep-environment*)))
  79.       (let ((*package* scheme-package)
  80.         (*readtable* scheme-readtable))
  81.     (multiple-value-call
  82.       #'(lambda (&optional (thing nil thing-p))
  83.           (if thing-p
  84.           `(scheme-form ,thing)
  85.           (values)))
  86.       (read stream nil 0 t)))
  87.       (let ((*readtable* scheme-hacks:*non-scheme-readtable*))
  88.     (read stream nil 0 t))))
  89.  
  90. (let ((*readtable* roadblock-readtable))
  91.   (mapc #'(lambda (s)
  92.         (map nil
  93.          #'(lambda (c)
  94.              (set-macro-character c #'roadblock-read-macro nil))
  95.          s))
  96.     ;; Intentionally absent: right parenthesis, semicolon, whitespace
  97.     '(
  98.       ;; Non-constituents
  99.       "\"#'(,`"
  100.       ;; Constituents (more or less)
  101.       ;;
  102.       ;; Actually we don't want to hack these, since otherwise the
  103.       ;; printer (which we can't hook, in general) will be
  104.       ;; printing all symbols as |FOO|.  This will only matter for
  105.       ;; symbol evaluation at an unhooked REP or debugging loop,
  106.       ;; where evaluation is supposed to be in some environment
  107.       ;; other than that initial one.
  108.       ;;
  109.       ;; On the other hand, if in some implementation we CAN
  110.       ;; reliably hook the printer, or else sufficiently restrict
  111.       ;; the use of the roadblock readtable (e.g. by passing it
  112.       ;; explicitly to LOAD and COMPILE-FILE), then we SHOULD
  113.       ;; block the constituent characters.  Thus I have left them
  114.       ;; here in this comment.
  115.       ;;
  116.       ;; "!$%&*+-./0123456789:<=>?"
  117.       ;; "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_"
  118.       ;; "abcdefghijklmnopqrstuvwxyz{|}~"
  119.       )))
  120.  
  121. (defmacro scheme-form (&whole whole form)
  122.   (let* ((new-form (translate-scheme-form form))
  123.      (new-form (if (consp new-form) new-form `(progn ,new-form))))
  124.     ;; The following tries to compensate for some versions of LOAD and
  125.     ;; COMPILE-FILE that imagine that macroexpansion is cheap.
  126.     (setf (car whole) (car new-form))
  127.     (setf (cdr whole) (cdr new-form))
  128.     new-form))
  129.  
  130. ; Use ROADBLOCK-EVAL to evaluate a form that was known to have been
  131. ; read by the roadblock readtable.
  132.  
  133. (defun roadblock-eval (form environment)
  134.   (cond ((and (consp form) (eq (car form) 'scheme-form))
  135.      (scheme-eval (cadr form) environment))
  136.     ((symbolp form)
  137.      (scheme-eval form environment))
  138.     (t
  139.      (eval form))))
  140.  
  141. (defvar *scheme-file-type* (preferred-case "SCM"))
  142.  
  143. (defmacro without-requiring-in-package (&body body)
  144.   #-Lucid
  145.   `(progn ,@body)
  146.   #+Lucid
  147.   `(lcl:handler-bind ((lcl:simple-warning
  148.                #'(lambda (c)
  149.                (when (search "does not begin with IN-PACKAGE"
  150.                     (lcl:simple-condition-format-string c))
  151.                  (lcl:invoke-restart 'lcl:muffle-warning)))))
  152.              ,@body))
  153.  
  154. ; LOAD
  155.  
  156. (defun scheme-load (filespec &optional env
  157.                  &rest keys)
  158.   (when (keywordp env) (push env keys) (setq env nil))
  159.   (using-environment env
  160.     #'(lambda (env)
  161.     (without-requiring-in-package
  162.      (apply #'scheme-hacks:clever-load filespec
  163.         :source-type (or (getf keys :source-type)
  164.                  *scheme-file-type*)
  165.         :message (format nil "into ~s environment"
  166.                  (program-env-id env))
  167.         #+LispM :package #+LispM (program-env-package env)
  168.         keys)))))
  169.  
  170. ; COMPILE-FILE
  171.  
  172. (defun scheme-compile-file (filespec &optional env
  173.                      &rest keys)
  174.   (when (keywordp env) (push env keys) (setq env nil))
  175.   (using-environment env
  176.     #'(lambda (env)
  177.     (let ((path
  178.            (merge-pathnames filespec
  179.                 (make-pathname :type *scheme-file-type*))))
  180.       (format t "~&Compiling ~A using ~S environment~%" (namestring path)
  181.           (program-env-id env))
  182.       (without-requiring-in-package
  183.        (apply #'compile-file
  184.           path
  185.           #+LispM :package #+LispM (program-env-package env)
  186.           keys))))))
  187.  
  188. ; using-environment: auxiliary for LOAD and COMPILE-FILE.
  189. ;  - *readtable* is bound to roadblock-readtable so that the translator
  190. ;    will kick in.  Top-level forms (foo) read as (scheme-form (foo))).
  191. ;  - *target-environment* is bound in order to communicate the appropriate
  192. ;    environment to the translator.
  193. ;  - *target-package* is bound in case we're loading a file of translated
  194. ;    code (extension .pso) produced by translate-file.  In this case,
  195. ;    evaluation of the (schi:begin-translated-file) at the top of the
  196. ;    file will set *package* to *target-package* and *readtable* to a
  197. ;    standard Common Lisp readtable.
  198.  
  199. (defun using-environment (env fun)
  200.   (let ((env (or env *target-environment*)))
  201.     (let ((*readtable* roadblock-readtable)
  202.       (*target-environment* env)
  203.       (*target-package* (program-env-package env)))
  204.       (funcall fun env))))
  205.     
  206.  
  207. ; TRANSLATE-FILE
  208.  
  209. (defun translate-file (filespec &optional (env *target-environment*))
  210.   (let ((path (merge-pathnames (if (symbolp filespec)
  211.                    (symbol-name filespec)
  212.                    filespec))))
  213.     (really-translate-file
  214.          (if (member (pathname-type path) '(nil :unspecific))
  215.          (make-pathname :type *scheme-file-type*
  216.                 :defaults path)
  217.          path)
  218.          (lisp:make-pathname :type *translated-file-type*
  219.                  :defaults path)
  220.          env)))
  221.  
  222. ; Auxiliary routine called when reading from Gnu Emacs using LEDIT package
  223.  
  224. (defun ledit-eval (filename form)
  225.   (declare (ignore filename))        ;for now
  226.   (if (eq *package* scheme-package)
  227.       (scheme-eval form *current-rep-environment*)
  228.       (eval form)))
  229.  
  230. (locally (declare (special user::*ledit-eval*))
  231.   (setq user::*ledit-eval* #'ledit-eval))
  232.  
  233. ;
  234.  
  235. (defun set-rep-environment! (env)
  236.   (setq *current-rep-environment* env)
  237.   (setq *target-environment* env)
  238.   (setq *target-package* (program-env-package env))
  239.   (values))
  240.  
  241. ; These things don't really belong here, but what the heck.
  242.  
  243. ; ERROR (nonstandard)
  244.  
  245. (defun scheme-error (message &rest irritants)
  246.   (if (or (not (stringp message))
  247.       (find #\~ message))
  248.       (apply #'error message irritants)
  249.       (apply #'error
  250.          (apply #'concatenate
  251.             'string
  252.             (if (stringp message) "~a" "~s")
  253.             (mapcar #'(lambda (irritant)
  254.                 (declare (ignore irritant))
  255.                 "~%  ~s")
  256.                 irritants))
  257.          message
  258.          irritants)))
  259.  
  260. #+LispM
  261. (setf (get 'scheme-error :error-reporter) t)  ;Thanks to KMP
  262.  
  263. ; PP (nonstandard)
  264.  
  265. (defun pp (obj &optional (port *standard-input*))
  266.   (let ((*print-pretty* t)
  267.     (*print-length* nil)
  268.     (*print-level* nil))
  269.     (format port "~&")
  270.     (print obj port)
  271.     (values)))
  272.  
  273. ; Set up "trampolines" to allow evaluation of Scheme forms directly by
  274. ; the Common Lisp evaluator.  Alsp, give some help to the pretty-printer
  275. ; by way of indicating where &bodies are.
  276.  
  277. (defun translate-scheme-form (form)
  278.   (translate form *target-environment*))
  279.  
  280. (defmacro scheme::case (key &body clauses)
  281.   (translate-scheme-form `(scheme::case ,key ,@clauses)))
  282.  
  283. (defmacro scheme::define (pat &body body)
  284.   (translate-scheme-form `(scheme::define ,pat ,@body)))
  285.  
  286. (defmacro scheme::define-syntax (pat &body body)
  287.   (translate-scheme-form `(scheme::define-syntax ,pat ,@body)))
  288.  
  289. (defmacro scheme::do (specs end &body body)
  290.   (translate-scheme-form `(scheme::do ,specs ,end ,@body)))
  291.  
  292. (defmacro scheme::lambda (bvl &body body)
  293.   (translate-scheme-form `(scheme::lambda ,bvl ,@body)))
  294.  
  295. (defmacro scheme::let (specs &body body)
  296.   (translate-scheme-form `(scheme::let ,specs ,@body)))
  297.  
  298. (defmacro scheme::let* (specs &body body)
  299.   (translate-scheme-form `(scheme::let* ,specs ,@body)))
  300.  
  301. (defmacro scheme::letrec (specs &body body)
  302.   (translate-scheme-form `(scheme::letrec ,specs ,@body)))
  303.  
  304. ; Other trampolines...
  305.  
  306. (defmacro translate-me (&whole form &rest rest)
  307.   (declare (ignore rest))
  308.   (translate-scheme-form form))
  309.  
  310. (mapc #'(lambda (scheme-sym)
  311.       ;; Allow (LISP:EVAL '(SCHEME::AND ...))
  312.       (setf (macro-function scheme-sym)
  313.         (macro-function 'translate-me)))
  314.       '(scheme::and
  315.     scheme::begin
  316.     scheme::cond
  317.     scheme::delay
  318.     scheme::cons-stream
  319.     scheme::if
  320.     scheme::or
  321.     scheme::quasiquote
  322.     scheme::quote
  323.     scheme::set!))
  324.  
  325. ; Read-eval-print loop
  326.  
  327. (defvar *rep-state-vars* '())
  328.  
  329. (defun enter-scheme ()
  330.   (declare (special translator-version)) ;inherited from translator package
  331.   (set-scheme-value '*package* scheme-package)
  332.   (set-scheme-value '*print-array* t)         ;for #(...)
  333.   (set-scheme-value '*print-case* :downcase)
  334.   (set-scheme-value '*readtable* roadblock-readtable)
  335.   (setq scheme-hacks:*non-scheme-readtable*
  336.     (get '*readtable* 'non-scheme-value))
  337.   (format t "~&This is ~A.~&" (translator-version))
  338.   (values))
  339.  
  340. (defun exit-scheme ()
  341.   (format t "~&Leaving Pseudoscheme.~&")
  342.   (mapc #'(lambda (var)
  343.         (let ((probe (get var 'non-scheme-value 'no-such-property)))
  344.           (unless (eq probe 'no-such-property)
  345.         (set-standard-value var probe))))
  346.     *rep-state-vars*)
  347.   (values))
  348.  
  349. (defun set-scheme-value (var value)
  350.   (pushnew var *rep-state-vars*)
  351.   (let ((old-value (symbol-value var)))
  352.     (unless (eq value old-value)
  353.       (setf (get var 'non-scheme-value) old-value))
  354.     (set-standard-value var value)))
  355.  
  356. (defun set-standard-value (var value)
  357.   #-Symbolics
  358.   (setf (symbol-value var) value)
  359.   #+Symbolics
  360.   (if (member var '(*package* *readtable* *print-array* *print-case*))
  361.       (setf (sys:standard-value var :setq-p t)
  362.         value)
  363.       (setf (symbol-value var) value)))
  364.  
  365. ;;; EVAL and PRINT functions to be used by the REP loop:
  366.  
  367. (defun scheme-rep-eval (exp)
  368.   (roadblock-eval exp *current-rep-environment*))
  369.  
  370. (defvar *result-display-style* :normalize)  ;or :eval
  371.  
  372. (defun write-result (result &optional (stream *standard-output*))
  373.   (if (and (eq *result-display-style* :normalize)
  374.        (not (or (eq result schi:true)  ;self-evaluating-p
  375.             (eq result schi:false)
  376.             (numberp result)
  377.             (characterp result)
  378.             (stringp result)
  379.             (scheme-hacks:photon-p result))))
  380.       (write-char #\' stream))
  381.   (funcall (scheme-hacks:intern-renaming-perhaps
  382.           "WRITE" (find-package "REVISED^4-SCHEME"))
  383.        result stream))
  384.  
  385. ; (SCHEME) and (QUIT) are system-specific REP loop entry and exit
  386. ; routines.
  387.  
  388. #-(or :DEC Symbolics) (progn
  389. (defun scheme ()
  390.   (enter-scheme))
  391.  
  392. (defun quit () 
  393.   (exit-scheme))
  394. ) ;end (progn ...)
  395.  
  396. #+:DEC (progn
  397. (defun scheme ()
  398.   (unwind-protect
  399.       (progn
  400.     (enter-scheme)
  401.     (system::read-eval-print-loop
  402.        "Scheme> "
  403.        :eval 'scheme-rep-eval
  404.        :print #'(lambda (vals stream)
  405.               (format stream "~&")
  406.               (do ((v vals (cdr v)))
  407.               ((null v) (values))
  408.             (write-result (car v) stream)
  409.             (if (not (null (cdr v)))
  410.                 (format stream " ;~%")))))
  411.     (values))
  412.     (exit-scheme)))
  413.  
  414. (defun quit ()
  415.   (vax-lisp:continue))
  416. ) ;end #+:DEC (progn ...)
  417.  
  418. #+Symbolics (progn 'compile
  419.  
  420. (defun scheme ()
  421.   "Initialize for execution of Scheme programs."
  422.   (enter-scheme)
  423.   (set-scheme-value 'si:*command-loop-eval-function*
  424.             'scheme-rep-eval)
  425.   (set-scheme-value 'si:*command-loop-print-function*
  426.             #'(lambda (values)
  427.             (mapc #'(lambda (value)
  428.                   (zl:send zl:standard-output :fresh-line)
  429.                   (write-result value))    ;?
  430.                   values)))
  431.   (values))
  432.  
  433. (defun quit ()
  434.   (exit-scheme))
  435. ) ;end #+Symbolics (progn ...)
  436.  
  437. ; Integrate built-ins in user environment
  438.  
  439. (defun benchmark-mode ()
  440.   (perform-usual-integrations! scheme-user-environment)
  441.   (values))
  442.  
  443. ; Mumble
  444.  
  445. (flet ((set-in-user-env (name val)
  446.          (set name val)
  447.      (schi:set-function-from-value name)))
  448.   (set-in-user-env 'scheme::quit  #'quit)
  449.   (set-in-user-env 'scheme::compile        #'scheme-compile)
  450.   (set-in-user-env 'scheme::compile-file   #'scheme-compile-file)
  451.   (set-in-user-env 'scheme::translate-file #'translate-file)
  452.   (set-in-user-env 'scheme::pp           #'pp)
  453.   (set-in-user-env 'scheme::error       #'scheme-error)
  454.   (set-in-user-env 'scheme::benchmark-mode #'benchmark-mode))
  455.  
  456.